home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 1.iso / ARGONET / PD / PROGRAMMING / PERL.SPK / Perl5001 / !Perl / Lib / pm / exporter < prev    next >
Encoding:
Text File  |  1995-03-13  |  3.7 KB  |  147 lines
  1. package Exporter;
  2.  
  3. =head1 Comments
  4.  
  5. If the first entry in an import list begins with /, ! or : then
  6. treat the list as a series of specifications which either add to
  7. or delete from the list of names to import. They are processed
  8. left to right. Specifications are in the form:
  9.  
  10.     [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
  11.     [!]name         This name only
  12.     [!]:tag         All names in $EXPORT_TAGS{":tag"}
  13.     [!]:DEFAULT     All names in @EXPORT
  14.  
  15. e.g., Foo.pm defines:
  16.  
  17.     @EXPORT      = qw(A1 A2 A3 A4 A5);
  18.     @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
  19.     %EXPORT_TAGS = (':T1' => [qw(A1 A2 B1 B2)], ':T2' => [qw(A1 A2 B3 B4)]);
  20.  
  21.     Note that you cannot use tags in @EXPORT or @EXPORT_OK.
  22.     Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
  23.  
  24. Application says:
  25.  
  26.     use Module qw(:T2 !B3 A3);
  27.     use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
  28.     use POSIX  qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
  29.  
  30. =cut
  31.  
  32. require 5.001;
  33.  
  34. $ExportLevel = 0;
  35. $Verbose = 0;
  36.  
  37. require Carp;
  38.  
  39. sub export {
  40.  
  41.     # First make import warnings look like they're coming from the "use".
  42.     local $SIG{__WARN__} = sub {
  43.     my $text = shift;
  44.     $text =~ s/ at \S*Exporter.pm line \d+.\n//;
  45.     local $Carp::CarpLevel = 1;    # ignore package calling us too.
  46.     Carp::carp($text);
  47.     };
  48.  
  49.     my $pkg = shift;
  50.     my $callpkg = shift;
  51.     my @imports = @_;
  52.     my($type, $sym);
  53.     *exports = \@{"${pkg}::EXPORT"};
  54.     if (@imports) {
  55.     my $oops;
  56.     *exports = \%{"${pkg}::EXPORT"};
  57.     if (!%exports) {
  58.         grep(s/^&//, @exports);
  59.         @exports{@exports} = (1) x  @exports;
  60.         foreach $extra (@{"${pkg}::EXPORT_OK"}) {
  61.         $exports{$extra} = 1;
  62.         }
  63.     }
  64.  
  65.     if ($imports[0] =~ m#^[/!:]#){
  66.         my(@allexports) = keys %exports;
  67.         my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  68.         my $tagdata;
  69.         my %imports;
  70.         # negated first item implies starting with default set:
  71.         unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
  72.         foreach (@imports){
  73.         my(@names);
  74.         my($mode,$spec) = m/^(!)?(.*)/;
  75.         $mode = '+' unless defined $mode;
  76.  
  77.         @names = ($spec); # default, maybe overridden below
  78.  
  79.         if ($spec =~ m:^/(.*)/$:){
  80.             my $patn = $1;
  81.             @names = grep(/$patn/, @allexports); # XXX anchor by default?
  82.         }
  83.         elsif ($spec =~ m#^:(.*)# and $tagsref){
  84.             if ($1 eq 'DEFAULT'){
  85.             @names = @exports;
  86.             }
  87.             elsif ($tagsref and $tagdata = $tagsref->{$1}) {
  88.             @names = @$tagdata;
  89.             }
  90.         }
  91.  
  92.         warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
  93.         if ($mode eq '!') {
  94.            map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
  95.         }
  96.         else {
  97.            @imports{@names} = (1) x @names;
  98.         }
  99.         }
  100.         @imports = keys %imports;
  101.     }
  102.  
  103.     foreach $sym (@imports) {
  104.         if (!$exports{$sym}) {
  105.         if ($sym !~ s/^&// || !$exports{$sym}) {
  106.             warn qq["$sym" is not exported by the $pkg module ],
  107.                 "at $callfile line $callline\n";
  108.             $oops++;
  109.             next;
  110.         }
  111.         }
  112.     }
  113.     die "Can't continue with import errors.\n" if $oops;
  114.     }
  115.     else {
  116.     @imports = @exports;
  117.     }
  118.     warn "Importing from $pkg into $callpkg: ",
  119.         join(", ",@imports),"\n" if ($Verbose && @imports);
  120.     foreach $sym (@imports) {
  121.     $type = '&';
  122.     $type = $1 if $sym =~ s/^(\W)//;
  123.     *{"${callpkg}::$sym"} =
  124.         $type eq '&' ? \&{"${pkg}::$sym"} :
  125.         $type eq '$' ? \${"${pkg}::$sym"} :
  126.         $type eq '@' ? \@{"${pkg}::$sym"} :
  127.         $type eq '%' ? \%{"${pkg}::$sym"} :
  128.         $type eq '*' ?  *{"${pkg}::$sym"} :
  129.             warn "Can't export symbol: $type$sym\n";
  130.     }
  131. };
  132.  
  133. sub import {
  134.     local ($callpkg, $callfile, $callline) = caller($ExportLevel);
  135.     my $pkg = shift;
  136.     export $pkg, $callpkg, @_;
  137. }
  138.  
  139. sub export_tags {
  140.     my ($pkg) = caller;
  141.     *tags = \%{"${pkg}::EXPORT_TAGS"};
  142.     push(@{"${pkg}::EXPORT"},
  143.     map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
  144. }
  145.  
  146. 1;
  147.